home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / free.t < prev    next >
Text File  |  1988-02-05  |  5KB  |  143 lines
  1. (herald free
  2.   (env tsys))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Freelist utilities
  28. ;;; Thanks and apologies to Bob Nix.
  29.  
  30. ;;; Could also have
  31. ;;;   FREE-LIST
  32. ;;;   FREE-APPEND
  33. ;;;   FREE-APPEND!
  34. ;;;   FREE-DEL
  35. ;;;   FREE-DELQ
  36. ;;;   FREE-` (this could be tough)
  37. ;;;   etc.
  38.  
  39. ;;; The last CDR of a freelist is #F and not () so as not to have to check
  40. ;;; for both.
  41.  
  42. (define-constant %%pair-pool-generate-count 1000)
  43.  
  44. (define-structure-type %freelist
  45.   weak
  46.   (((print-type-string self) "Freelist")))
  47.  
  48. (define-constant freelist? %freelist?)
  49.  
  50. (define (make-freelist)
  51.   (let ((n (make-%freelist)))
  52.     (set (%freelist-weak n) (make-weak-cell '#f))
  53.     n))
  54.  
  55. (define (cons-from-this-freelist f a d)
  56.   (let* ((weak (%freelist-weak f))
  57.          (pair (weak-cell-contents weak)))
  58.     (cond ((not pair)
  59.            (set (weak-cell-contents weak) (cons-up-a-freelist))
  60.            (cons a d))
  61.           (else
  62.            (set (weak-cell-contents weak) (cdr pair))
  63.            (set (car pair) a)
  64.            (set (cdr pair) d)
  65.            pair))))
  66.  
  67. (define (cons-up-a-freelist)
  68.   (iterate loop ((i 1) (freelist '#f))   ; #F instead of () is important
  69.     (cond ((fx= i %%pair-pool-generate-count)
  70.            freelist)
  71.           (else
  72.            (loop (fx+ i 1) (cons 'free freelist))))))
  73.  
  74. (define (return-to-this-freelist f cell)
  75.   (really-return-to-freelist (%freelist-weak f) cell)
  76.   nil)
  77.  
  78. (define (return-list-to-this-freelist f l)
  79.   (let ((weak (%freelist-weak f)))
  80.     (do ((l l (let ((n (cdr l))) (really-return-to-freelist weak l) n)))
  81.         ((atom? l)
  82.          nil))))
  83.  
  84. (define-constant (really-return-to-freelist weak pair)
  85.   (set (car pair) 'free)
  86.   (modify (weak-cell-contents weak)
  87.           (lambda (x)
  88.             (set (cdr pair) x)
  89.             pair)))
  90.  
  91. ;;; Compatibility junk
  92.  
  93. (define system-freelist
  94.   (make-freelist))
  95.  
  96. (define (cons-from-freelist a d)
  97.   (cons-from-this-freelist system-freelist a d))
  98.  
  99. (define (return-to-freelist cell)
  100.   (return-to-this-freelist system-freelist cell))
  101.  
  102. (define (return-list-to-freelist list)
  103.   (return-list-to-this-freelist system-freelist list))
  104.  
  105. ;;; Only works on one list...
  106. ;;; The N-list version is too gross.
  107.  
  108. (define (free-map proc l)
  109.   (cond ((null-list? l) '())
  110.         (else
  111.          (let ((result (cons-from-freelist (proc (car l)) '())))
  112.            (iterate loop ((l (cdr l)) (r result))
  113.              (cond ((null-list? l)
  114.                     result)
  115.                    (else
  116.                     (let ((q (cons-from-freelist (proc (car l)) '())))
  117.                       (set (cdr r) q)
  118.                       (loop (cdr l) q)))))))))
  119.  
  120.  
  121. (define (free-del! pred obj list)
  122.   (iterate loop ((list list))
  123.     (cond ((null-list? list) '())
  124.           ((pred obj (car list))
  125.            (let ((d (cdr list)))
  126.              (return-to-freelist list)
  127.              (loop d)))
  128.           (else
  129.            (set (cdr list) (loop (cdr list)))
  130.            list))))
  131.  
  132. (define (free-delq! obj list)
  133.   (iterate free-delq! ((list list))
  134.     (cond ((null-list? list) '())
  135.           ((eq? obj (car list))
  136.            (let ((d (cdr list)))
  137.              (return-to-freelist list)
  138.              (free-delq! d)))
  139.           (else
  140.            (set (cdr list) (free-delq! (cdr list)))
  141.            list))))
  142.  
  143.